perm filename FASLAP[NEW,LSP]2 blob
sn#388713 filedate 1978-10-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00022 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002
C00004 00003
C00006 00004
C00009 00005
C00013 00006
C00016 00007
C00019 00008
C00024 00009
C00025 00010
C00029 00011
C00036 00012
C00041 00013
C00045 00014
C00047 00015
C00049 00016
C00053 00017
C00057 00018
C00060 00019
C00063 00020
C00070 00021
C00071 00022
C00072 ENDMK
C⊗;
;;; -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** LISP ASSEMBLER (FASLAP) *****************
;;; **************************************************************
;;; ** (C) Copyright 1978 Massachusetts Institute of Technology **
;;; ****** This is a read-only file! (All writes reserved) *******
;;; **************************************************************
;;; This assembler is normally part of the compiler, and produces
;;; binary (FASL) files suitable for loading with FASLOAD.
(AND (NOT (STATUS FEATURE SAIL)) (PUTPROP 'EREAD (GET 'UREAD 'FSUBR) 'FSUBR))
(DECLARE (EVAL (READ))) ;No need for macros in final version
(PROGN
(SETSYNTAX '/#
'MACRO
'(LAMBDA () (COND ((= (TYIPEEK) 35.)
(TYI) ;Flush second #
(EVAL (READ)))
(T ((LAMBDA (DATA FFVL)
(AND (SETQ FFVL (GET (CAR DATA) 'MACRO))
(SETQ DATA (FUNCALL FFVL DATA)))
DATA)
(READ) ())))))
)
(SETQ FASLVERNO '##(COND ((CADDR (TRUENAME INFILE)))
('/310)))
(DEFUN FASLDECLARE MACRO (L)
(SPECIAL ALLATOMS AMBIGSYMS ATOMINDEX BINCT
CLPROGN CMSGFILES COBARRAY CREADTABLE
CURRENTFN CURRENTFNSYMS DATA DDTSYMP
DDTSYMS ENTRYNAMES EXPR FASLEVAL
FASLPUSH FASLVERNO FBARP FILOC FSLFLD
GOFOO IMOBFL IMOSAR IMOUSR LASTENTRY
LDFNM LITCNT LITERALP LITERALS LITLOC
LOC MAINSYMPDL MAKUNBOUND MESSIOC MSDEV
MSDIR OUTFILES
SOBARRAY SQUID SQUIDP SYMBOLS SYMBOLSP
SYMPDL TTYNOTES UFFIL UNDEFSYMS
UNFASLCOMMENTS UNFASLSIGNIF
)
(*FEXPR EREAD)
(*EXPR *DDTSYM ARGSINFO ATOMINDEX BLOBLENGTH
BUFFERBIN COLLECTATOMS
FASLDEFSYM FASLDIFF FASLEVAL FASLINIT
FASLMAIN FASLMINUS FASLNEGLIS
FASLPASS1 FASLPASS2 FASLPLUS FASLVERNO
INDENT-TO-INSTACK LAPCONST LISTOUT
LREMPROP MAKEWORD MESOUT MOBYSYMPOP MSOUT
MUNGEABLE REMPROPL SUBMATCH
)
(FIXNUM (BLOBLENGTH) (ATOMINDEX) (ARGSINFO)
(RECLITCOUNT) N I TYP FILOC LOC LITLOC LITCNT BINCT)
(ARRAY* (NOTYPE (LCA 16.) (BSAR 9.) (NUMBERTABLE 127.))
(FIXNUM (BTAR 9.) (BXAR 9.)))
(GENPREFIX /|FL)
(MAPEX T)
'(COMMENT FASLDECLARE))
(DECLARE (COUTPUT '(FASLAPSETUP/| T)) ;Have necessary SYMS set up so DDTSYMS in
(FASLDECLARE)) ;file wont actually cause requests to DDT
(COMMENT MACRO DEFUNITIONS AND INLINEABLE EXPRS)
;;; Redefine DISPLACE into something harmless if making up a *PURE
;;; version of the assembler in EXPR code
##(COND ((OR (MEMQ COMPILER-STATE '(MAKLAP DECLARE)) (NULL *PURE)) ())
((SUBST (GENSYM)
'X
'(DEFUN DISPLACE MACRO (X) (LIST 'QUOTE (EVAL (CADDR X))))) ))
;;; DEFUN-ILE is a macro which expands into (DEFUN <FN> MACRO ...).
;;; It allows macro definitions to be written in a natural way, using
;;; dummy parameters and a template. Eventually, it will mean
;;; "Inline-able Expr"
(DEFUN DEFUN-ILE MACRO (X)
((LAMBDA (ARGNAME MATCHOVER)
(SUBLIS (LIST (CONS 'name (CADR X))
(CONS 'arg ARGNAME)
(CONS 'subsl (FUNCALL MATCHOVER
(CADDR X)
(LIST 'CDR ARGNAME)))
(CONS 'body (COND ((CDDDDR X)
(CONS 'PROGN (CDDDR X)))
((CADDDR X)))))
(COND ((NULL (CADDR X))
'(DEFUN name MACRO (arg)
(DISPLACE arg 'body)))
('(DEFUN name MACRO (arg)
(DISPLACE arg (SUBLIS (LIST . subsl) 'body)))))))
(GENSYM)
'(LAMBDA (PAT VL)
(COND ((ATOM PAT)
(COND ((NULL PAT) ())
((SYMBOLP PAT) (LIST 'CONS (LIST 'QUOTE PAT) VL))
((ERROR PAT '|NON-BINDABLE ATOM -- DEFUN-ILE|))))
(T (CONS (FUNCALL MATCHOVER (CAR PAT) (LIST 'CAR VL))
(FUNCALL MATCHOVER (CDR PAT) (LIST 'CDR VL)))))) ))
(DEFUN-ILE BARF (item msg a1 a2) (MSOUT item 'msg 'BARF a1 a2))
(DEFUN-ILE DBARF (item msg a1 a2) (MSOUT item 'msg 'DATA a1 a2))
(DEFUN-ILE WARN (item msg a1 a2) (MSOUT item 'msg 'WARN a1 a2))
(DEFUN-ILE PDERR (item msg) (MSOUT item 'msg 'ERRFL 4 6))
(COMMENT RUN-TIME SETUP CODE FOR FASLAP)
;;; NOTE: THE LIST OF GLOBALSYMS SHOULD CORRESPOND TO
;;; THE LIST OF SYMBOLS AT LOCATION LSYMS IN LISP.
(DEFUN FASLVERNO ()
(PRINC '|/
FASLAP Assembler |)
(PRINC FASLVERNO)
(PRINC '| |))
(DEFUN FASLINIT ()
(GETMIDASOP ())
((LAMBDA (OBARRAY PROPS ACS FL)
(MAPATOMS '(LAMBDA (X) (LREMPROP X PROPS)))
(SETQ LDFNM (FASLAPSETUP/| ()))
(COND ((AND (BOUNDP 'COBARRAY)
(EQ (TYPEP COBARRAY) 'ARRAY)
(SETQ FL (ARRAYDIMS COBARRAY))
(EQ (CAR FL) 'OBARRAY)
(NOT (AND (BOUNDP 'SOBARRAY) (EQ SOBARRAY COBARRAY))))
(SETQ FL '(% @ BLOCK ASCII SIXBIT SQUOZE CALL NCALL JCALL NJCALL
ENTRY DEFSYM BLOCK SYMBOLS BEGIN DDTSYM
THIS IS THE UNFASL FOR LISP FILE COMPILED BY COMPILER))
(MAPATOMS '(LAMBDA (X) (AND (GETL X '(SYM GLOBALSYM)) (PUSH X FL))))
;;;AFTER THE FASLAPSETUP/|, ONLY SYMS SHOULD BE GLOBALSYMS. IN ORDER:
;*SET *MAP PRINTA SPECBIND UNBIND IOGBND *LCALL *UDT ARGLOC
;INUM ST FXNV1 PDLNMK PDLNKJ FIX1A FIX1 FLOAT1 IFIX IFLOAT
;FXCONS FLCONS ERSETUP ERUNDO GOBRK CARCDR *STORE NPUSH PA3
;MAKUNBOUND FLTSKP FXNV2 FXNV3 FXNV4 FIX2 FLOAT2 AREGET
;UINITA UTIN INTREL INHIBIT NOQUIT CHECKI 0PUSH 0*0PUSH
;NILPROPS VBIND %CXR %RPX
(SETQ OBARRAY COBARRAY)
(MAPC 'INTERN FL) ;CROSS-INTERNS GLOBALSYMS
(MAPC 'INTERN (APPEND PROPS ACS))) ;PLUS A FEW OTHER WORDS
(T (SETQ COBARRAY OBARRAY CREADTABLE READTABLE)))
(SETQ MSDEV 'DSK SQUIDP ()) ;LISTS AND SET UP GLOBALSYMS
(DO ((I 0 (1+ I)) (L ACS (CDR L))) ;NOW DEFINE SYMS FOR LISP ACS
((NULL L))
(AND (NOT (EQ (CAR L) 'FOO)) (PUTPROP (CAR L) I 'SYM)))
(ARRAY LCA T 16.) (ARRAY NUMBERTABLE T 127.)
(ARRAY BTAR FIXNUM 9.) (ARRAY BXAR FIXNUM 9.) (ARRAY BSAR T 9.)
(DO I 0 (1+ I) (= I 16.) (STORE (LCA I) (CONS I '((() -1)))))
(SETQ IMOSAR () IMOUSR ())
(SSTATUS FEATURE FASLAP)
(GCTWA))
OBARRAY
'(SYM ATOMINDEX ARGSINFO ENTRY GLOBALSYM)
'(FOO A B C AR1 AR2A T TT D R F FOO P FLP FXP SP)
()))
;;; FASL-A-FILE SHOULD ONLY BE CALLED BY MAKLAP, FOR MAKLAP BINDS LOTS OF LOSING SPECIAL VARIABLES
;;; HOWEVER, FASLTRY TRYES TO SIMULATE THIS CALL FOR A TEST CASE
(DEFUN FASL-A-FILE (TARGETFILE SOURCEFILES)
((LAMBDA (BASE IBASE OBARRAY READTABLE MSDIR EOF WINP REALSFS TOPFN)
(ERRSET
(PROGN
(GCTWA T)
(FASL-START TARGETFILE ())
(DO SFS SOURCEFILES (CDR SFS) (NULL SFS)
(APPLY 'EREAD (CAR SFS)) ;OPEN LAP SOURCE FILE
(PUSH (STATUS UREAD) REALSFS)
(UNFASL-MSG (CAR REALSFS))
(SETQ ↑Q T)
(DO Y
(READ EOF)
(AND ↑Q (READ EOF))
(OR (NULL ↑Q) (EQ Y EOF))
(FASLIFY Y ())))
(SETQ WINP T)))
(GCTWA ())
(COND ((OR (NULL WINP) FBARP) ;IF SOME ERROR OCCURRED,
(SETQ TOPFN CURRENTFN)
(PDERR (LIST LOC FILOC) |Faslization aborted after so many words| )
(AND ↑Q (DO () ((EQ EOF (READ EOF))))) ;CLEAN OUT TO END OF FILE
(SETQ REALSFS ()) ;IDENTIFY LOSER TO FASL-CLOSEOUT
(ERR 'FASLAP)))
(FASL-CLOSEOUT TARGETFILE REALSFS TARGETFILE)
(AND TTYNOTES
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 0)
(PRIN1 (COND ((NULL (CDR SOURCEFILES)) (CAR SOURCEFILES))
(SOURCEFILES)))
(PRINC '| assembled - |)
(PRIN1 FILOC)
(PRINC '| Words|)))
(GCTWA)
WINP)
8. BASE COBARRAY CREADTABLE MSDIR (LIST ()) () () ()))
(DEFUN FASLIFY (LL FL)
(PROG (Y)
(COND ((EQ FL 'LIST))
((OR (EQ FL 'LAP) (AND (NULL FL) (NOT (ATOM LL)) (EQ (CAR LL) 'LAP)))
(DO ((Z LL (AND ↑Q (READ EOF))) (EOF (LIST ())))
((NULL Z) (SETQ LL (NREVERSE (CONS () Y))))
(AND (NULL ↑Q)
(PROG2 (PDERR CURRENTFN |Has EOF in middle of LAP code|)
(ERR 'FASLAP)))
(PUSH Z Y)))
(FL (SETQ FBARP T)
(BARF () |FASLIFY is losing|))
(T (SETQ Y LL LL ()) (GO B)))
A (AND (NULL LL) (RETURN ()))
(SETQ Y (CAR LL))
B (COND ((ATOM Y)) ;IGNORE RANDOM ATOMS
((EQ (CAR Y) 'LAP) ;PROCESS LAP
(SETQ CURRENTFN (CADR Y))
(FASLPASS1 LL)
(SETQ LL (FASLPASS2 LL))
(SETQ FILOC (+ FILOC LOC))
(AND (NOT (EQ COMPILER-STATE 'COMPILE))
TTYNOTES
(PROG (↑W ↑R)
(INDENT-TO-INSTACK 0)
(PRIN1 CURRENTFN)
(PRINC '| Assembled|))))
((MUNGEABLE Y) (COLLECTATOMS Y) (BUFFERBIN 14. -1←18. Y))
(T (COND ((EQ (CAR Y) 'DECLARE)
(ERRSET (MAPC 'EVAL (CDR Y)) ())
(SETQ Y ()))
((OR (EQ (CAR Y) 'COMMENT) (NOT (EQ (CAR Y) 'QUOTE))))
((SUBMATCH (CADR Y) '(THIS IS THE LAP FOR))
(SETQ Y (AND UNFASLCOMMENTS
(SUBST (CADDDR (CDDADR Y))
'DATA
''(THIS IS THE UNFASL FOR LISP FILE DATA)))))
((SUBMATCH (CADR Y) '(COMPILED BY LISP COMPILER))
(SETQ Y ())))
(COND ((AND Y (OR UNFASLCOMMENTS (NOT (MEMQ (CAR Y) '(COMMENT QUOTE)))))
((LAMBDA (↑R ↑W OUTFILES)
(TERPRI) ;PUT THE NON-MUNGEABLE INTO UNFASL FILE
(COND ((AND (NOT (ATOM Y)) (EQ (CAR Y) 'QUOTE))
(PRINC '/') (SETQ Y (CADR Y))))
(PRIN1 Y) (PRINC '/ ))
T T UFFIL)
(SETQ UNFASLSIGNIF T)))))
(SETQ LL (CDR LL))
(GO A)))
(DEFUN FASL-START (FILE CONTINUEP)
((LAMBDA (USR)
(SETQ IMOSAR (OPEN (CONS (CAR FILE) (CONS '/←FASL/← (CDDR FILE)))
'(OUT FIXNUM DSK)))
(COND ((NOT CONTINUEP)
(SETQ UFFIL (LIST (OPEN (LIST (CAR FILE) '/←UNFA/← MSDEV USR)
'(OUT))))
(PUSH (CAR UFFIL) CMSGFILES)
(LINEL (CAR UFFIL) 80.)
(AND (SETQ USR (PROBEF IMOSAR)) (DELETEF USR))
(AND (SETQ USR (PROBEF (CAR UFFIL))) (DELETEF USR)) )) ;OPEN FASL OUTPUT FILE
(FASLOUT 124641635413) ;FIRST OF TWO WORD HEADER IS SIXBIT |*FASL+|
(FASLOUT LDFNM)
(SETQ ALLATOMS (SETQ ENTRYNAMES (SETQ SYMPDL
(SETQ MAINSYMPDL (SETQ CURRENTFNSYMS ())))))
(SETQ BINCT 0)
(FILLARRAY 'NUMBERTABLE '(()) )
(SETQ FILOC (SETQ LITLOC (SETQ LOC (SETQ ATOMINDEX 0))))
(SETQ ↑W (SETQ ↑R T)))
(COND (MSDIR)
((CADDDR FILE))
((CADR (CRUNIT))) )))
(DEFUN FASL-CLOSEOUT (TARGETFILE SOURCEFILES UNFASLNAM)
(AND UNFASLNAM
(SETQ UNFASLNAM (CONS (CAR UNFASLNAM) '(UNFASL))))
(BUFFERBIN 17 0 ()) ;END OF FILE FLAG
(AND (NOT SOURCEFILES)
(SETQ TARGETFILE (CONS '/.FASL/. (CONS 'OUTPUT (CDDR TARGETFILE)))))
(COND ((AND (STATUS FEATURES SAIL)
(PROBEF TARGETFILE))
(DELETEF TARGETFILE)))
(RENAMEF IMOSAR TARGETFILE)
(SETQ IMOSAR ()) ;CLOSE BINARY OUTPUT FILE
(COND (SOURCEFILES
(AND UNFASLCOMMENTS
(NOTE-IN-UNFASL '|TOTAL = | FILOC '| WORDS|)) ;Close UNFASL file
(COND ((NULL UNFASLNAM)) ;If kill-flag permits, and
('T (COND ((AND (STATUS FEATURES SAIL)
(PROBEF UNFASLNAM))
(DELETEF UNFASLNAM)))
(RENAMEF (CAR UFFIL) UNFASLNAM)
(AND (NULL UNFASLSIGNIF) (DELETEF (CAR UFFIL)))
(SETQ UFFIL () ))))
(T (DELETEF TARGETFILE) ;KILL FASL FILE,
(COND ((AND (STATUS FEATURES SAIL)
(PROBEF UNFASLNAM))
(DELETEF UNFASLNAM)))
(COND ((AND UFFIL UNFASLNAM) ; IF WRONG OR INSIGNIF
(RENAMEF (CAR UFFIL) UNFASLNAM)
(SETQ UFFIL () )))
(MOBYSYMPOP MAINSYMPDL)
(REMPROPL 'SYM CURRENTFNSYMS)))
(REMPROPL 'ENTRY ENTRYNAMES) ;FLUSH NO-LONGER-NEEDED PROPERTIES
(REMPROPL 'ARGSINFO ENTRYNAMES)
(REMPROPL 'ATOMINDEX ALLATOMS)
(FILLARRAY 'BSAR '(()) )
(FILLARRAY 'NUMBERTABLE '(()) )
(SETQ ALLATOMS (SETQ ENTRYNAMES (SETQ SYMPDL
(SETQ MAINSYMPDL (SETQ CURRENTFNSYMS () ))))))
(DEFUN UNFASL-MSG (FILE)
((LAMBDA (↑W OUTFILES TERPRI)
(PRINC '|/
'(THIS IS THE UNFASL FOR |) ;BARF OUT HEADER
(PRIN1 FILE) ; FOR UNFASL FILE
(PRINC '|)/
'(ASSEMBLED BY FASLAP //|)
(PRINC FASLVERNO)
(PRINC '|)/
|))
T UFFIL T))
(DEFUN NOTE-IN-UNFASL (MSG W FL)
((LAMBDA (↑R ↑W OUTFILES TERPRI BASE *NOPOINT)
(PRINC '|/
(COMMENT **FASL** |) ;Precede COMMENT with CR/LF
(PRINC MSG)
(AND W (PRINC '| |) (PRIN1 W))
(AND FL (PRINC FL))
(PRINC '|)|)
(AND ↑R (SETQ UNFASLSIGNIF ↑R)))
T T UFFIL T 10. ()))
;;; FASLPASS1 PERFORMS PASS 1 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES DEFINING SYMBOLS AND SAVING VARIOUS PIECES
;;; OF INFORMATION FOR PASS 2.
(DEFUN FASLPASS1 (Q) ;Q HAS (LAP FOO SUBR) OR WHATEVER
((LAMBDA (BASE IBASE)
(PROG (AMBIGSYMS N EXPR)
(AND (NOT (EQ (CAAR Q) 'LAP))
(SETQ FBARP T)
(BARF Q |Not a LAP listing - FASLPASS1|))
(SETQ LOC 0)
(SETQ CURRENTFN (CADAR Q) CURRENTFNSYMS ())
(PUSH CURRENTFN ENTRYNAMES)
(PUTPROP CURRENTFN FILOC 'ENTRY)
(AND UNFASLCOMMENTS (NOTE-IN-UNFASL FILOC (CAR Q) ())) ;Tells about entry points
(DO Z (CDR Q) (CDR Z) (COND ((NULL Z)
(BARF () |No () [or "NIL"] in LAP code - FASLPASS1|)
(SETQ FBARP T))
((NULL (SETQ EXPR (CAR Z)))))
(COND ((ATOM EXPR)
(FASLDEFSYM EXPR (LIST 'RELOC (+ FILOC LOC))))
((EQ (CAR EXPR) 'ENTRY)
(COND ((GET (CADR EXPR) 'ENTRY)
(PDERR CURRENTFN |Multiple ENTRY with duplicated name|)
(ERR 'FASLAP))
(T (PUSH (CADR EXPR) ENTRYNAMES)
(PUTPROP (CADR EXPR) (SETQ DATA (+ FILOC LOC)) 'ENTRY)
(AND UNFASLCOMMENTS
(NOTE-IN-UNFASL DATA EXPR ())))))
((EQ (CAR EXPR) 'DEFSYM) ;DEFSYM
(DO X (CDR EXPR) (CDDR X) ;SO DEFINE THE SYMBOLS
(NOT (AND X (CDR X))) ;NOTE THAT EVAL IS USED,
(FASLDEFSYM (CAR X) (EVAL (CADR X))))) ; NOT FASLEVAL
((EQ (CAR EXPR) 'DDTSYM) ;DECLARE DDT SYMBOLS
(SETQ DDTSYMP T) ;REMEMBER THAT THIS FN HAD DDTSYM
(MAPC (FUNCTION *DDTSYM) (CDR EXPR))) ;TRY TO GET THEM FROM DDT
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'SYMBOLS) ;SYMBOLS - FOR NOW, JUST
(SETQ SYMBOLSP T)) ; REMEMBER THAT ONE HAPPENED
((MEMQ (CAR EXPR) '(SIXBIT ASCII BLOCK)) ;HAIRY BLOBS
(SETQ LOC (+ LOC (SETQ N (BLOBLENGTH EXPR)))))
((NOT (MEMQ (CAR EXPR) '(COMMENT ARGS)))
(RECLITCOUNT EXPR T)
(SETQ LOC (1+ LOC)))))
(SETQ LITLOC LOC) ;REMEMBER WHERE TO ASSEMBLE LITERALS
(SETQ LITERALS (NREVERSE LITERALS))))
8. 8.))
(DEFUN RECLITCOUNT (EXPR FL) ;FL SAYS WHETHERON PASS1 OR NOT
(COND ((AND (CDR EXPR) ;ON PASS1, MERELY ASCERTAIN NUMBER
(CDDR EXPR) ;OF CODE WORDS USING LITERALS
(SETQ EXPR (COND ((OR (EQ (CADDR EXPR) '/@)
(EQ (CADR EXPR) '/@))
(CADDDR EXPR))
((CADDR EXPR))))
(NOT (ATOM EXPR))
(EQ (CAR EXPR) '%)
(NOT (LAPCONST (CDR EXPR))))
(COND (FL (PUSH (CDR EXPR) LITERALS) 0) ;ON PASS1, NOT REALLY INTERESTED IN COUNT
((MEMQ (CADR EXPR) '(SIXBIT ASCII BLOCK)) (BLOBLENGTH EXPR))
((1+ (RECLITCOUNT EXPR ())))))
(0)))
;;; FASLPASS2 PERFORMS PASS 2 PROCESSING FOR A LAP FUNCTION.
;;; THIS INCLUDES RETRIEVING INFORMATION SAVED ON PASS 1
;;; (IN PARTICULAR SYMBOLS), HANDLING DDT SYMBOLS TO BE
;;; RETRIEVED AT LOAD TIME, PROCESSING LITERALS, DEFINING
;;; ENTRY POINTS TO THE LOADER, AND OF COURSE CONVERTING
;;; INSTRUCTIONS TO BINARY CODE. THE FUNCTION MAKEWORD IS
;;; CALLED TO PROCESS INDIVIDUAL LAP STATEMENTS.
(DEFUN FASLPASS2 (Q) ;Q HAS LAP LISTING
((LAMBDA (BASE IBASE LITCNT)
(PROG (DDTSYMS AMBIGSYMS LASTENTRY ENTRYPOINTS LITERALP
UNDEFSYMS OLOC EXPR OLITERALS LL N TEM)
(SETQ OLITERALS LITERALS OLOC LOC LOC 0)
(COLLECTATOMS (CDR (SETQ EXPR (CAR Q)))) ;MUST COLLECT NAME AND TYPE OF SUBR
(PUSH (CONS (CONS (CADR EXPR) (CADDR EXPR)) (GET CURRENTFN 'ENTRY))
ENTRYPOINTS) ;SAVE ENTRY POINT INFO
(COND ((GET CURRENTFN 'SYMBOLSP) ;SYMBOLS PSEUDO ANYWHERE MAKES ENTRY DEFINED
(BUFFERBIN 15 0 CURRENTFN))) ; - OUTPUT AS DDT SYMBOL
(SETQ LASTENTRY CURRENTFN)
(DO Z (CDR Q) (CDR Z) (COND ((NULL (SETQ EXPR (CAR Z)))
(SETQ LL Z)
T))
(COND ((ATOM EXPR) ;MAYBE A TAG SHOULD BE
(COND (SYMBOLSP (BUFFERBIN 15 0 EXPR)))) ; OUTPUT AS A DDT SYMBOL
((EQ (CAR EXPR) 'ENTRY) ;ENTRY POINT
(COND ((NOT (= (SETQ N (+ FILOC LOC))
(GET (CADR EXPR) 'ENTRY))) ;BETTER BE AT
(BARF (CADR EXPR) |Phase screw at ENTRY - FASLPASS2|)))
(COLLECTATOMS (CDR EXPR)) ;COLLECT NAME AND TYPE
(PUSH (CONS (CONS (CADR EXPR) ;SAVE INFO ABOUT ENTRY
(COND ((CDDR EXPR)
(CADDR EXPR))
((CADDAR Q))))
N)
ENTRYPOINTS)
(AND SYMBOLSP (BUFFERBIN 15 0 (CADR EXPR)))
(SETQ LASTENTRY (CADR EXPR)))
((EQ (CAR EXPR) 'ARGS) ;ARGS DECLARATION
(COND ((EQ (CADR EXPR) LASTENTRY) ;SHOULD BE JUST AFTER ENTRY
(PUTPROP (CADR EXPR) (CADDR EXPR) 'ARGSINFO)) ;SAVE INFO
('T (COND ((GET (CADR EXPR) 'ENTRY) ;TWO WAYS TO BARF AT LOSER
(PDERR EXPR |Misplaced ARGS info|))
((PDERR EXPR |Function not seen for this info|)))
(ERR 'FASLAP)) ))
((EQ (CAR EXPR) 'SYMBOLS) ;TURN DDT SYMBOLS OUTPUT
(SETQ SYMBOLSP (CADR EXPR))) ; SWITCH ON OR OFF
((EQ (CAR EXPR) 'EVAL) ;EVALUATE RANDOM FROBS
(MAPC (FUNCTION EVAL) (CDR EXPR)))
((EQ (CAR EXPR) 'DDTSYM) ;SAVE DDTSYMS TO PUT
(MAPC '(LAMBDA (X) (AND (NOT (MEMQ X DDTSYMS)) (PUSH X DDTSYMS)))
(CDR EXPR)))
((NOT (MEMQ (CAR EXPR) '(DEFSYM COMMENT))) (MAKEWORD EXPR))))
(AND (OR LITERALS (NOT (= LOC LITLOC))) (GO PHAS))
(SETQ LITERALP T) ;THIS LETS FASLEVAL KNOW WE'RE DOING LITERALS
(MAPC (FUNCTION MAKEWORD) OLITERALS) ;SO ASSEMBLE ALL THEM LITERALS
(AND (NOT (= LOC (+ LITLOC LITCNT))) (GO PHAS))
(MAPC '(LAMBDA (X)
(SETQ TEM (GET (CAAR X) 'ARGSINFO))
(BUFFERBIN 13 (BOOLE 7 (LSH (ARGSINFO (CAR TEM)) 27.)
(LSH (ARGSINFO (CDR TEM)) 18.)
(CDR X))
(CAR X)))
ENTRYPOINTS)
(AND DDTSYMS ;BARF ABOUT DDT SYMBOLS
(COND ((NULL DDTSYMP)
(WARN DDTSYMS |Undefined symbols - converted to DDT symbols|))
((WARN DDTSYMS |DDT symbols|))))
(AND UNDEFSYMS (PROG2 (PDERR UNDEFSYMS |Undefined symbols|)
(ERR 'FASLAP)))
(REMPROPL 'SYM CURRENTFNSYMS)
(REMPROPL 'SYM DDTSYMS)
(MOBYSYMPOP SYMPDL) ;RESTORE DISPLACED SYMBOLS
(RETURN LL) ;NORMAL EXIT
PHAS (BARF () |Literal phase screw|)))
8. 8. 0))
(DEFUN ARGSINFO (X) (COND ((NULL X) 0) ((= X 511.) X) ((1+ X))))
;;; FASLEVAL IS ONLY USED BY MAKEWORD, TO EVALUATE THE
;;; FIELDS OF A LAP INSTRUCTION.
(DEFUN FASLEVAL (X) ;EVALUATE HAIRY FASLAP EXPRESSION
(COND ((NUMBERP X) X) ;A NUMBER IS A NUMBER IS A NUMBER
((ATOM X)
(COND ((EQ X '*) (LIST 'RELOC (+ FILOC LOC))) ;* IS THE LOCATION COUNTER
((GET X 'GLOBALSYM)) ;TRY GETTING GLOBARSYM PROP
((GET X 'SYM)) ;TRY GETTING SYM PROPERTY
((OR (NULL X) (MEMQ X UNDEFSYMS)) 0) ;0 FOR LOSING CASES
(((LAMBDA (Y) (AND Y (PUTPROP X Y 'SYM))) (GETMIDASOP X)))
((NULL DDTSYMP) ;MAYBE CAN PASS THE BUCK ON
(PUSH X DDTSYMS) ; TO FASLOAD (IT WILL GET
(*DDTSYM X)) ; SYMBOL FROM DDT WHEN LOADING)
(T (PUSH X UNDEFSYMS) 0))) ;OH, WELL, GUESS IT'S UNDEFINED
((EQ (CAR X) 'QUOTE)
(COND ((ATOM (CADR X)) X)
((EQ (CAADR X) SQUID)
(COND ((EQ (CADR (SETQ X (CADR X))) MAKUNBOUND)
'(0 (() 34)))
(X)))
((EQ (CDADR X) GOFOO) (LIST 'EVAL (CAADR X)))
(X)))
((OR (MEMQ (CAR X) '(SPECIAL FUNCTION ARRAY)) (EQ (CAR X) SQUID)) X)
((EQ (CAR X) 'EVAL) (CONS SQUID (CDR X)))
((EQ (CAR X) '%)
(COND ((NOT (= FSLFLD 1)) ;LITERALS MUST BE IN ADDRESS FIELD
(PDERR X |Literal not in address field|)
(ERR 'FASLAP))
((LAPCONST (CDR X))) ;MAYBE IT'S A LAP CONSTANT
((NOT LITERALP)
(SETQ LITERALS (CDR LITERALS)) ;KEEPING COUNT OF THE NUMBER OF LITERALS
((LAMBDA (RLC)
(SETQ LITCNT
(+ LITCNT
(COND ((MEMQ (CADR X) '(SIXBIT ASCII BLOCK))
(BLOBLENGTH (CDR X)))
((ZEROP (RECLITCOUNT (CDR X) ())) 1)
(T (SETQ RLC (+ RLC (RECLITCOUNT (CDR X) ())))
(- RLC LITCNT -1)))))
(LIST 'RELOC (+ FILOC LITLOC RLC)))
LITCNT))
((PROG2 () ;HO! HO! HO! YOU THINK THIS WILL WORK??
(FASLEVAL '*)
(MAKEWORD (CDR X))))))
((MEMQ (CAR X) '(ASCII SIXBIT)) ;A WORD OF ASCII
(CAR (PNGET (CADR X)
(COND ((EQ (CAR X) 'ASCII) 7) (6))))) ;OR OF SIXBIT
((EQ (CAR X) 'SQUOZE) ;A WORD OF SQUOZE [MAY BE EITHER
(SQOZ/| (CDR X))) ; (SQUOZE SYMBOL) OR (SQUOZE # SYMBOL)]
((EQ (CAR X) '-) ;SUBTRACTION (OR MAYBE NEGATION)
(COND ((NULL (CDDR X))
(FASLMINUS (FASLEVAL (CADR X))))
((FASLDIFF (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))))
((EQ (CAR X) '+) ;ADDITION
(FASLPLUS (FASLEVAL (CADR X))
(FASLEVAL (CDDR X))))
((CDR X) (FASLPLUS (FASLEVAL (CAR X)) ;A RANDOM LIST GETS ADDED UP
(FASLEVAL (CDR X))))
((FASLEVAL (CAR X))))) ;SUPERFLUOUS PARENS - RE-FASLEVAL
;;; THE VALUE OF FASLEVAL IS ONE OF THE FOLLOWING FROBS:
;;; <NUMBER> A NUMBER
;;; (<NUMBER> -GLITCHES-) NUMBER (PLUS GLITCHES)
;;; (RELOC <NUMBER> -GLITCHES-) RELOCATABLE VALUE (PLUS GLITCHES)
;;; (SPECIAL <ATOM>) REFERENCE TO VALUE CELL
;;; (QUOTE <S-EXPRESSION>) S-EXPRESSION CONSTANT
;;; (FUNCTION <ATOM>) REFERENCE TO FUNCTION [SAME AS (QUOTE <ATOM>)]
;;; (ARRAY <ATOM>) REFERENCE TO ARRAY POINTER
;;; FOO RESULT OF INVALID ARGS TO FASLEVAL
;;;
;;; A "GLITCH" IS ONE OF THE FOLLOWING:
;;; (() <NUMBER> . <SIGN>) GLOBALSYM [<NUMBER> INDICATES WHICH ONE]
;;; (<SQUOZE> () . <SIGN>) DDT SYMBOL, VALUE UNKNOWN [<SQUOZE> IS A NUMBER]
;;; (<SQUOZE> <VALUE> . <SIGN>) DDT SYMBOL, VALUE KNOWN TO DDT ABOVE FASLAP
;;; <SIGN> IS EITHER - FOR NEGATIVE OR () FOR POSITIVE.
;;;
;;; FASLPLUS, FASLMINUS, AND FASLDIFF ARE USED TO PERFORM ARITHMETIC ON THESE FROBS.
;;; NO ARITHMETIC CAN BE PERFORMED ON THE SPECIAL, QUOTE, FUNCTION, ARRAY, AND FOO FROBS.
;;; ARITHMETIC CAN BE PERFORMED ON ALL THE OTHERS, EXCEPT THAT ONE CANNOT CREATE
;;; A NEGATIVE RELOC FROB, I.E. ONE CAN SUBTRACT A RELOC FROM A RELOC, BUT NOT
;;; A RELOC FROM AN ABSOLUTE.
(DEFUN FASLPLUS (K Q) ;ADD TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (+ K Q))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ K (CADR Q)) (CDDR Q))))
((NUMBERP (CAR Q))
(CONS (+ K (CAR Q)) (CDR Q)))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (+ Q (CADR K)) (CDDR K))))
((NUMBERP (CAR Q))
(CONS 'RELOC (CONS (+ (CAR Q) (CADR K))
(APPEND (CDR Q) (CDDR K)))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (+ Q (CAR K)) (CDR K)))
((EQ (CAR Q) 'RELOC)
(CONS 'RELOC (CONS (+ (CAR K) (CADR Q))
(APPEND (CDR K) (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS (+ (CAR K) (CAR Q))
(APPEND (CDR K) (CDR Q))))
('FOO)))
('FOO)))
(DEFUN FASLDIFF (K Q) ;SUBTRACT TWO FROBS
(COND ((NUMBERP K)
(COND ((NUMBERP Q) (- K Q))
((NUMBERP (CAR Q))
(CONS (- K (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
((EQ (CAR K) 'RELOC)
(COND ((NUMBERP Q)
(CONS 'RELOC (CONS (- (CADR K) Q) (CDDR K))))
((EQ (CAR Q) 'RELOC)
(CONS (- (CADR K) (CADR Q))
(APPEND (CDDR K) (FASLNEGLIS (CDDR Q)))))
((NUMBERP (CAR Q))
(CONS 'RELOC
(CONS (- (CADR K) (CAR Q))
(APPEND (CDDR K)
(FASLNEGLIS (CDR Q))))))
('FOO)))
((NUMBERP (CAR K))
(COND ((NUMBERP Q)
(CONS (- (CAR K) Q) (CDR K)))
((NUMBERP (CAR Q))
(CONS (- (CAR K) (CAR Q))
(APPEND (CDR K) (FASLNEGLIS (CDR Q)))))
('FOO)))
('FOO)))
(DEFUN FASLMINUS (Q) ;NEGATE A FROB
(COND ((NUMBERP Q) (- Q))
((NUMBERP (CAR Q))
(CONS (- (CAR Q)) (FASLNEGLIS (CDR Q))))
('FOO)))
(DEFUN FASLNEGLIS (K) ;NEGATES A LIST OF GLITCHES
(MAPCAR (FUNCTION (LAMBDA (Q)
(CONS (CAR Q)
(CONS (CADR Q)
(COND ((CDDR Q) ())
('-))))))
K))
;;; LAPCONST IS A "SEMI-PREDICATE" WHICH WHEN APPLIED TO THE CDR
;;; OR A LITERAL DETERMINES WHETHER OR NOT IT IS ONE OF A NUMBER
;;; OF SPECIAL "LAP CONSTANTS" WHICH ARE DEFINED IN LISP (IN A
;;; TABLE AT LOCATION R70) SINCE COMPILED CODE USES THEM SO OFTEN.
;;; IF NOT, IT RETURNS (); IF SO, IT RETURNS A FASLEVAL FROB
;;; INDICATING A REFERENCE TO R70 AS A GLOBALSYM.
(DEFUN LAPCONST (X) ;SPECIAL LAP CONSTANTS ARE
(COND ((NOT (SIGNP E (CAR X)))
(AND (NULL (CDR X)) (LAPC1 (CAR X)))) ;(% '()), (% FIX1), OR (% FLOAT1)
((NULL (CDR X)) '(0 (() -1))) ;(% 0) OR (% 0.0)
((OR (NOT (FIXP (CADR X)))
(NOT (= (CADR X) 0))
(NULL (SETQ X (CDDR X))))
())
((NULL (CDR X)) (LAPC1 (CAR X))) ;(% 0 0 '()), (% 0 0 FIX1), OR (% 0 0 FLOAT1)
((AND (FIXP (CAR X))
(< (CAR X) 16. )
(> (CAR X) 0)
(FIXP (CADR X))
(= (CAR X) (CADR X)))
(LCA (CAR X))))) ;(% 0 0 N N) FOR 0 < N < 16.
(DEFUN LAPC1 (X)
(COND ((EQ X 'FIX1) '(-2 (() -1)))
((EQ X 'FLOAT1) '(-1 (() -1)))
((AND (EQ (TYPEP X) 'LIST) (EQ (CAR X) 'QUOTE) (EQ (CADR X) '())
'(0 (() -1))))))
;;; ATOMINDEX IS USED TO RETRIEVE THE INDEX OF AN ATOM (THIS
;;; INDEX MUST HAVE BEEN PREVIOUSLY DEFINED BY COLLECTATOMS).
;;; SYMBOL ATOMS HAVE ATOMINDEX PROPERTIES; INDICES OF
;;; NUMBERS ARE KEPT IN A HASH TABLE CALLED NUMBERTABLE.
(DEFUN ATOMINDEX (X TYPE)
(COND ((NULL X) 0)
(T (AND (NULL TYPE) (SETQ TYPE (TYPEP X)))
(SETQ TYPE (COND ((EQ TYPE 'SYMBOL) (GET X 'ATOMINDEX))
((NOT (MEMQ TYPE '(FIXNUM FLONUM BIGNUM))) ())
((CDR (HASSOCN X TYPE)))))
(AND (NULL TYPE) (BARF X |Atomindex screw|))
TYPE)))
;;; COLLECTATOMS FINDS ALL ATOMS IN AN S-EXPRESSION AND ASSIGNS AN ATOMINDEX
;;; TO EACH ONE WHICH DOESN'T ALREADY HAVE ONE. THESE INDEX ASSIGNMENTS ARE ALSO
;;; OUTPUT INTO THE BINARY FILE. IT IS THROUGH THESE INDICES THAT S-EXPRESSIONS
;;; ARE DESCRIBED TO THE LOADER.
(DEFUN COLLECTATOMS (X) ;COLLECT ALL ATOMS IN AN S-EXPRESSION
(AND X ;() IS ALWAYS PRE-COLLECTED
(PROG (TYPE)
A (COND ((EQ (SETQ TYPE (TYPEP X)) 'LIST)
(COLLECTATOMS (CAR X))
(AND (SETQ X (CDR X)) (GO A)))
((EQ TYPE 'SYMBOL)
(COND ((NULL (GET X 'ATOMINDEX))
(PUSH X ALLATOMS)
(PUTPROP X (SETQ ATOMINDEX (1+ ATOMINDEX)) 'ATOMINDEX)
(BUFFERBIN 12 0 X))))
((MEMQ TYPE '(FIXNUM FLONUM BIGNUM))
((LAMBDA (BKT)
(COND ((NULL (CDR BKT))
(SETQ ATOMINDEX (1+ ATOMINDEX))
(RPLACD BKT (LIST (CONS TYPE (CONS X ATOMINDEX))))
(BUFFERBIN 12 0 X))))
(HASSOCN X TYPE)))))))
(DEFUN HASSOCN (X TYPE)
(PROG (BKT OBKT FIXFLOP I)
(SETQ FIXFLOP (MEMQ TYPE '(FIXNUM FLONUM)))
(SETQ I (\ (ABS (SXHASH X)) 127.))
(AND (MINUSP I) (SETQ I 0))
(SETQ OBKT (NUMBERTABLE I))
A (COND ((NULL (SETQ BKT (CDR OBKT)))
(RETURN (COND (OBKT) ;RETURN (<MUMBLE> . ())
((STORE (NUMBERTABLE I) (LIST ())))))) ;THE "LAST" OF A BKT
((NOT (EQ TYPE (CAAR BKT))))
((COND ((NOT FIXFLOP) (EQUAL X (CADAR BKT)))
(T (= X (CADAR BKT))))
(RETURN (CDAR BKT)))) ;RETURN (N . INDEX)
(SETQ OBKT BKT)
(GO A)))
;;; FASLDEFSYM IS USED TO DEFINE SYMBOLS; IT ALSO CHECKS FOR VARIOUS
;;; ERRORS, INCONSISTENCIES, AND AMBIGUITIES.
(DEFUN FASLDEFSYM (SYM VAL) ;DEFINE A SYMBOL
(PROG (Z)
(COND ((GET SYM 'GLOBALSYM)
(PDERR SYM |Cant redefine a GLOBALSYM - FASLDEFSYM|)
(ERR 'FASLAP))
((SETQ Z (GET SYM 'SYM)) ;MAYBE IT'S ALREADY DEFINED?
(COND ((EQUAL Z VAL) (RETURN Z)) ;REDEFINING TO SAME VALUE DOESN'T HURT
((NOT (MEMQ SYM AMBIGSYMS)) ;ELSE IT IS AN AMBIGUOUS SYMBOL
(PUSH SYM AMBIGSYMS) ;OH, WE'LL REDEFINE IT, ALL RIGHT,
(AND (NOT (MEMQ SYM CURRENTFNSYMS)) ; BUT WE'LL ALSO BARF
(SETQ MAINSYMPDL (PUSH (CONS SYM Z) SYMPDL))))))
(T (PUSH SYM CURRENTFNSYMS)))
(RETURN (PUTPROP SYM VAL 'SYM)))) ;SO DEFINE THE SYMBOL (MUST RETURN THE VALUE)
(DEFUN BLOBLENGTH (X) ;DETERMINES THE LENGTH OF A BLOB
(COND ((EQ (CAR X) 'SIXBIT) ;SIXBIT
(// (+ 5 (FLATC (CADR X))) 6))
((EQ (CAR X) 'ASCII) ;ASCII
(// (+ 4 (FLATC (CADR X))) 5))
((NUMBERP (SETQ DATA (CADR X))) DATA) ;MUST BE BLOCK - ACCEPT NUMBER
((AND (SYMBOLP DATA) ;ACCEPT SYMBOL WHOSE VALUE IS NUMBER
(NUMBERP (SETQ DATA (GET DATA 'SYM))))
DATA)
(T (PDERR X |Undefined arg for block expression|)
(ERR 'FASLAP) )))
(DEFUN SUBMATCH (X Y) ;"true" IFF LIST Y IS A PREFIX OF LIST X
(DO ((X X (CDR X)) (Y Y (CDR Y)))
((NULL Y) T)
(AND (NULL X) (RETURN ())) ;X WAS TOO SHORT
(AND (NOT (EQ (CAR X) (CAR Y))) (RETURN ())))) ;THEY DONT MATCH
(DEFUN MUNGEABLE (X) ;SHOULD RANDOM S-EXPR BE PUT IN BINARY FILE
(NOT (OR (MEMQ (CAR X) '(QUOTE COMMENT DECLARE)) ;NOT IF QUOTED OR COMMENT
(AND (EQ (CAR X) 'EVAL) ;NOT IF (EVAL 'FOO)
(EQ (TYPEP (CADR X)) 'LIST) ; (THIS GIVES US A HOOK TO
(EQ (CAADR X) 'QUOTE))))) ; AVOID MUNGING IF DESIRED)
(DEFUN MOBYSYMPOP (L)
(DO X L (CDR X) (NULL X)
(PUTPROP (CAAR X) (CDAR X) 'SYM)))
;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS.
;;; EACH LIST-SPEC MAY BE AS FOLLOWS:
;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N
;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM
;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS
;;; 300000,,0 MERELY EVALUATE THE TOP THING ON THE STACK
;;; 7XXXXD,,INS TERMINATE, D IS INFORMATION DIGIT, INS MAY BE
;;; THE LH OF THE INSTRUCTION FOR A TYPE 5 WORD
;;; LISTOUT DOES NOT GENERATE THE TERMINATION WORDC
(DEFUN LISTOUT (X)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'RANDOM)
(PDERR LOC |Relative location of QUOTE randomness|)
(ERR 'FASLAP))
((NOT (EQ TYPE 'LIST)) (FASLOUT (ATOMINDEX X TYPE)))
((EQ (CAR X) SQUID)
(SETQ SQUIDP T)
(LISTOUT (CADR X))
(FASLOUT 3←41))
((DO ((I 0 (1+ I)) (Y X (CDR Y)) (FL) (N 0))
((OR (NULL Y) (SETQ FL (ATOM Y)))
(SETQ N (COND (FL (LISTOUT Y) 2←41) (1←41)) I (BOOLE 7 I N))
(FASLOUT I))
(LISTOUT (CAR Y))))))
(TYPEP X)))
;;; BUFFERBIN TAKES TWO ARGUMENTS: A NUMBER, WHICH IS THE
;;; RELOCATION TYPE, AND SOME OBJECT. THE FORMAT OF THIS SECOND
;;; OBJECT DEPENDS ON THE TYPE, AS FOLLOWS:
;;; # TYPE FORMAT OF SECOND AND THIRD OBJECTS
;;; 0 ABSOLUTE <FIXNUM>
;;; 1 RELOCATABLE <FIXNUM>
;;; 2 SPECIAL <FIXNUM>
;;; 3 SMASHABLE CALL <FIXNUM>
;;; 4 QUOTED ATOM <FIXNUM> ATOM
;;; 5 QUOTED LIST <FIXNUM> <LIST>
;;; 6 GLOBALSYM <FIXNUM>
;;; 7 GETDDTSYM <SQUOZE-VAL> <() OR FIXNUM>
;;; 10 ARRAY REFERENCE <ATOMINDEX>
;;; 11 [UNUSED]
;;; 12 ATOMINDEX INFO 0 <ATOM>
;;; 13 ENTRY INFO ARGSINFO (<NAME> . <TYPE>)
;;; 14 LOC <FIXNUM>
;;; 15 PUTDDTSYM 0 <ATOM>
;;; 16 EVAL MUNGEABLE <-N,,0> <RANDOM-SEXP>
;;; 17 END OF BINARY [IGNORED - IN PRACTICE () IS USED]
(DEFUN BUFFERBIN (TYP N X)
(STORE (BTAR BINCT) TYP)
(STORE (BXAR BINCT) N)
(STORE (BSAR BINCT) X)
(COND ((AND (NOT (= TYP 17)) (< BINCT 8.)) (SETQ BINCT (1+ BINCT)))
(T (DO ((N 0 (BOOLE 7 (LSH N 4) (BTAR I))) ;PACK 9 TYPE BYTES INTO
(I 0 (1+ I))) ;ONE WORD
((> I BINCT) (FASLOUT (LSH N (* 4 (- 8. BINCT))))))
(DO I 0 (1+ I) (> I BINCT)
(SETQ TYP (BTAR I) N (BXAR I))
(COND ((OR (< TYP 5) (= TYP 6) (= TYP 8.)) (FASLOUT N))
(T (SETQ X (BSAR I))
(COND ((= TYP 5)
(SETQ SQUIDP ())
(LISTOUT X)
(FASLOUT (BOOLE 7 -1←18. (LSH N -18.)))
(FASLOUT (COND (SQUIDP 0) ((SXHASH X)))))
((= TYP 10.)
((LAMBDA (TYPE)
(COND ((EQ TYPE 'SYMBOL)
(SETQ X (PNGET X 7))
(FASLOUT (LENGTH X))
(MAPC 'FASLOUT X))
((EQ TYPE 'BIGNUM)
(FASLOUT (BOOLE 7 3←33.
(COND ((MINUSP X) 7←18.) (0))
(LENGTH (CDR X))))
(MAPC 'FASLOUT (REVERSE (CDR X))))
((MEMQ TYPE '(FIXNUM FLONUM))
(FASLOUT (COND ((EQ TYPE 'FIXNUM) 1←33.) (2←33.)))
(FASLOUT (LSH X 0)))
(T (BARF (LIST TYP N X) | - BUFFERBIN screw|))))
(TYPEP X)))
((= TYP 11.)
(FASLOUT (BOOLE 7 (LSH (ATOMINDEX (CAR X) 'SYMBOL) 18.)
(ATOMINDEX (CDR X) 'SYMBOL)))
(FASLOUT N))
((= TYP 14.) (LISTOUT X) (FASLOUT N))
((= TYP 15.) (FASLOUT 11383814923.)) ;SIXBIT FOR |*FASL+|
((= TYP 7) (FASLOUT N) (AND X (FASLOUT X)))
((= TYP 13.) (FASLOUT (SQOZ/| (LIST X))))
(T (BARF (LIST TYP N X) | - BUFFERBIN screw|))))))
(SETQ BINCT 0))))
(DEFUN POPNCK@ MACRO (L)
(SUBST (CADR L)
'tag
'(COND ((NULL (SETQ L (CDR L))) (GO DONE))
((EQ (CAR L) '/@) (SETQ WRD (BOOLE 7 WRD 20←18.)) (GO tag)))))
(DEFUN MKEVAL MACRO (L)
(SUBST (CADR L)
'n
'(PROG2 (SETQ FSLFLD n)
(AND (EQ (SETQ SYM (FASLEVAL (CAR L))) 'FOO) (GO MKWERR))
(SETQ TYPE (TYPEP SYM)))))
(DEFUN MAKEWORD (L)
(DECLARE (FIXNUM WRD NN II REL))
(PROG (WRD NN SYM TYPE OPGL ACGL ADDRGL INDXGL NOGL REL SYL OL)
(SETQ NOGL T REL 0 WRD 0 OL L)
(COND ((EQ (CAR L) 'SQUOZE)
(BINOUT (SQOZ/| (CDR L)))
(SETQ LOC (1+ LOC))
(RETURN ()))
((EQ (CAR L) 'BLOCK)
(SETQ TYPE (TYPEP (SETQ SYM (CADR L))))
(AND (EQ TYPE 'SYMBOL) (SETQ TYPE (TYPEP (SETQ SYM (GET SYM 'SYM)))))
(AND (NOT (EQ TYPE 'FIXNUM)) (GO MKWERR))
(DO II SYM (1- II) (ZEROP II) (BINOUT 0))
(SETQ LOC (+ LOC SYM))
(RETURN ()))
((COND ((EQ (CAR L) 'ASCII) (SETQ NN 7) T)
((EQ (CAR L) 'SIXBIT) (SETQ NN '6) T))
(MAPC 'BINOUT (SETQ SYM (PNGET (CADR L) NN)))
(SETQ LOC (+ LOC (LENGTH SYM)))
(RETURN ())))
(MKEVAL 3)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 WRD (CADR SYM))
(AND (SETQ OPGL (CDDR SYM)) (SETQ NOGL ())))
((NUMBERP (CAR SYM)) (SETQ NOGL () OPGL (CDR SYM) WRD (CAR SYM)))
(T (GO MKWERR)))
A (POPNCK@ A)
(MKEVAL 2)
(COND ((EQ TYPE 'FIXNUM) (SETQ WRD (+ WRD (ROT (BOOLE 1 SYM 17) -13.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL () ACGL (CDR SYM))
(SETQ WRD (BOOLE 7 WRD (ROT (BOOLE 1 (CAR SYM) 17) -13.))))
(T (GO MKWERR)))
B (POPNCK@ B)
(MKEVAL 1)
(COND ((EQ TYPE 'FIXNUM) (SETQ NN SYM))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM)) (SETQ NOGL () ADDRGL (CDR SYM) NN (CAR SYM)))
((PROG2 (SETQ SYL (CADR SYM)) (MEMQ (CAR SYM) '(QUOTE FUNCTION)))
(COLLECTATOMS SYL)
(SETQ REL (COND ((NOT (EQ (SETQ TYPE (TYPEP SYL)) 'LIST))
(SETQ NN (ATOMINDEX SYL TYPE)) 4)
(T (SETQ ADDRGL SYL NN 0) 5))))
((COND ((EQ (CAR SYM) 'SPECIAL) (SETQ REL 2) T)
((EQ (CAR SYM) 'ARRAY) (SETQ REL 10) T))
(COLLECTATOMS SYL)
(AND (NOT (SYMBOLP SYL)) (GO MKWERR))
(SETQ NN (ATOMINDEX SYL 'SYMBOL)))
((EQ (CAR SYM) 'RELOC)
(SETQ REL 1 NN (CADR SYM))
(AND (SETQ ADDRGL (CDDR SYM)) (SETQ NOGL ())))
((COND ((EQ (CAR SYM) 'EVAL)
(SETQ ADDRGL (CONS SQUID (CDR SYM)))
T)
((EQ (CAR SYM) SQUID) (SETQ ADDRGL SYM) T))
(COLLECTATOMS SYL)
(SETQ REL 5))
(T (GO MKWERR)))
(SETQ WRD (BOOLE 7 (BOOLE 1 WRD -1←18.) (BOOLE 1 (+ WRD NN) 777777)))
C (POPNCK@ C)
(MKEVAL 0)
(COND ((MEMQ TYPE '(FIXNUM FLONUM)) (SETQ WRD (+ WRD (ROT SYM 18.))))
((NOT (EQ TYPE 'LIST)) (GO MKWERR))
((NUMBERP (CAR SYM))
(SETQ NOGL () INDXGL (CDR SYM) WRD (+ WRD (ROT (CAR SYM) 18.))))
(T (GO MKWERR)))
DONE (AND (= REL 4) (MEMQ (CAR OL) '(CALL JCALL NCALL NJCALL)) (SETQ REL 3))
(SETQ LOC (1+ LOC))
(BUFFERBIN REL WRD (AND (= REL 5) (PROG2 () ADDRGL (SETQ ADDRGL ()))))
(COND ((NOT NOGL)
(AND OPGL (GLHAK OPGL 3))
(AND ACGL (GLHAK ACGL 2))
(AND ADDRGL (GLHAK ADDRGL 1) (GO MKWERR))
(AND INDXGL (GLHAK INDXGL 0))))
(RETURN ())
MKWERR (PDERR OL |- Ill-formed expression - MAKEWORD|)
(ERR 'FASLAP)))
(DEFUN GLHAK (GLITCH FIELD)
(DECLARE (FIXNUM FIELD))
(COND ((NULL (CAAR GLITCH))
(COND ((NOT (= FIELD 1))) ;RETURNS "true" IF LOSES
(T (BUFFERBIN 6
(BOOLE 7 (COND ((CDDAR GLITCH) -4←41) (0))
(BOOLE 1 (CADAR GLITCH) 777777))
())
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(T (BUFFERBIN 7
(BOOLE 7 (COND ((CDDAR GLITCH) -4←41) (0)) ;PLUS OR MINUS?
(COND ((CADAR GLITCH) 2←41) (0)) ;VALUE KNOWN AT ASSEMBLY TIME?
(ROT FIELD -4) ;FIELD NUMBER
(CAAR GLITCH)) ;SQUOZE REPRESENTATION
(CADAR GLITCH)) ;GUESS AT SYMVAL
(AND (CDR GLITCH) (GLHAK (CDR GLITCH) FIELD)))))
(DEFUN BINOUT (X) (BUFFERBIN 0 X ()))
(DEFUN *DDTSYM (SYM) (FASLDEFSYM SYM (LIST '0 (LIST (SQOZ/| (LIST SYM)) (GETDDTSYM SYM)))))
(DEFUN FASLOUT (X) (OUT IMOSAR X))
;;; SOMEBODY ELSE (NORMALLY INITIALIZE IN COMPLR)
;;; MUST CALL FASLINIT BEFORE FASLAP CAN BE USED!
(SSTATUS FEATURE FASLAP)
(GCTWA)